home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl67.lha / tcl6.7 / tclCmdMZ.c < prev    next >
C/C++ Source or Header  |  1993-01-29  |  36KB  |  1,433 lines
  1. /* 
  2.  * tclCmdMZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    M to Z.  It contains only commands in the generic core (i.e.
  7.  *    those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright 1987-1991 Regents of the University of California
  10.  * Permission to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose and without
  12.  * fee is hereby granted, provided that the above copyright
  13.  * notice appear in all copies.  The University of California
  14.  * makes no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without
  16.  * express or implied warranty.
  17.  */
  18.  
  19. #ifndef lint
  20. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.18 93/01/29 09:40:49 ouster Exp $ SPRITE (Berkeley)";
  21. #endif
  22.  
  23. #include "tclInt.h"
  24.  
  25. /*
  26.  * Structure used to hold information about variable traces:
  27.  */
  28.  
  29. typedef struct {
  30.     int flags;            /* Operations for which Tcl command is
  31.                  * to be invoked. */
  32.     int length;            /* Number of non-NULL chars. in command. */
  33.     char command[4];        /* Space for Tcl command to invoke.  Actual
  34.                  * size will be as large as necessary to
  35.                  * hold command.  This field must be the
  36.                  * last in the structure, so that it can
  37.                  * be larger than 4 bytes. */
  38. } TraceVarInfo;
  39.  
  40. /*
  41.  * Forward declarations for procedures defined in this file:
  42.  */
  43.  
  44. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  45.                 Tcl_Interp *interp, char *name1, char *name2,
  46.                 int flags));
  47.  
  48. /*
  49.  *----------------------------------------------------------------------
  50.  *
  51.  * Tcl_RegexpCmd --
  52.  *
  53.  *    This procedure is invoked to process the "regexp" Tcl command.
  54.  *    See the user documentation for details on what it does.
  55.  *
  56.  * Results:
  57.  *    A standard Tcl result.
  58.  *
  59.  * Side effects:
  60.  *    See the user documentation.
  61.  *
  62.  *----------------------------------------------------------------------
  63.  */
  64.  
  65.     /* ARGSUSED */
  66. int
  67. Tcl_RegexpCmd(dummy, interp, argc, argv)
  68.     ClientData dummy;            /* Not used. */
  69.     Tcl_Interp *interp;            /* Current interpreter. */
  70.     int argc;                /* Number of arguments. */
  71.     char **argv;            /* Argument strings. */
  72. {
  73.     int noCase = 0;
  74.     int indices = 0;
  75.     regexp *regexpPtr;
  76.     char **argPtr, *string;
  77.     int match, i;
  78.  
  79.     if (argc < 3) {
  80.     wrongNumArgs:
  81.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  82.         " ?-nocase? exp string ?matchVar? ?subMatchVar ",
  83.         "subMatchVar ...?\"", (char *) NULL);
  84.     return TCL_ERROR;
  85.     }
  86.     argPtr = argv+1;
  87.     argc--;
  88.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  89.     if (strcmp(argPtr[0], "-indices") == 0) {
  90.         argPtr++;
  91.         argc--;
  92.         indices = 1;
  93.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  94.         argPtr++;
  95.         argc--;
  96.         noCase = 1;
  97.     } else {
  98.         break;
  99.     }
  100.     }
  101.     if (argc < 2) {
  102.     goto wrongNumArgs;
  103.     }
  104.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  105.     if (regexpPtr == NULL) {
  106.     return TCL_ERROR;
  107.     }
  108.  
  109.     /*
  110.      * Convert the string to lower case, if desired, and perform
  111.      * the match.
  112.      */
  113.  
  114.     if (noCase) {
  115.     register char *dst, *src;
  116.  
  117.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  118.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  119.         if (isupper(*src)) {
  120.         *dst = tolower(*src);
  121.         } else {
  122.         *dst = *src;
  123.         }
  124.     }
  125.     *dst = 0;
  126.     } else {
  127.     string = argPtr[1];
  128.     }
  129.     tclRegexpError = NULL;
  130.     match = regexec(regexpPtr, string);
  131.     if (string != argPtr[1]) {
  132.     ckfree(string);
  133.     }
  134.     if (tclRegexpError != NULL) {
  135.     Tcl_AppendResult(interp, "error while matching pattern: ",
  136.         tclRegexpError, (char *) NULL);
  137.     return TCL_ERROR;
  138.     }
  139.     if (!match) {
  140.     interp->result = "0";
  141.     return TCL_OK;
  142.     }
  143.  
  144.     /*
  145.      * If additional variable names have been specified, return
  146.      * index information in those variables.
  147.      */
  148.  
  149.     argc -= 2;
  150.     if (argc > NSUBEXP) {
  151.     interp->result = "too many substring variables";
  152.     return TCL_ERROR;
  153.     }
  154.     for (i = 0; i < argc; i++) {
  155.     char *result, info[50];
  156.  
  157.     if (regexpPtr->startp[i] == NULL) {
  158.         if (indices) {
  159.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  160.         } else {
  161.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  162.         }
  163.     } else {
  164.         if (indices) {
  165.         sprintf(info, "%d %d", regexpPtr->startp[i] - string,
  166.             regexpPtr->endp[i] - string - 1);
  167.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  168.         } else {
  169.         char savedChar, *first, *last;
  170.  
  171.         first = argPtr[1] + (regexpPtr->startp[i] - string);
  172.         last = argPtr[1] + (regexpPtr->endp[i] - string);
  173.         savedChar = *last;
  174.         *last = 0;
  175.         result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  176.         *last = savedChar;
  177.         }
  178.     }
  179.     if (result == NULL) {
  180.         Tcl_AppendResult(interp, "couldn't set variable \"",
  181.             argPtr[i+2], "\"", (char *) NULL);
  182.         return TCL_ERROR;
  183.     }
  184.     }
  185.     interp->result = "1";
  186.     return TCL_OK;
  187. }
  188.  
  189. /*
  190.  *----------------------------------------------------------------------
  191.  *
  192.  * Tcl_RegsubCmd --
  193.  *
  194.  *    This procedure is invoked to process the "regsub" Tcl command.
  195.  *    See the user documentation for details on what it does.
  196.  *
  197.  * Results:
  198.  *    A standard Tcl result.
  199.  *
  200.  * Side effects:
  201.  *    See the user documentation.
  202.  *
  203.  *----------------------------------------------------------------------
  204.  */
  205.  
  206.     /* ARGSUSED */
  207. int
  208. Tcl_RegsubCmd(dummy, interp, argc, argv)
  209.     ClientData dummy;            /* Not used. */
  210.     Tcl_Interp *interp;            /* Current interpreter. */
  211.     int argc;                /* Number of arguments. */
  212.     char **argv;            /* Argument strings. */
  213. {
  214.     int noCase = 0, all = 0;
  215.     regexp *regexpPtr;
  216.     char *string, *p, *firstChar, *newValue, **argPtr;
  217.     int match, result, flags;
  218.     register char *src, c;
  219.  
  220.     if (argc < 5) {
  221.     wrongNumArgs:
  222.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  223.         " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
  224.     return TCL_ERROR;
  225.     }
  226.     argPtr = argv+1;
  227.     argc--;
  228.     while (argPtr[0][0] == '-') {
  229.     if (strcmp(argPtr[0], "-nocase") == 0) {
  230.         argPtr++;
  231.         argc--;
  232.         noCase = 1;
  233.     } else if (strcmp(argPtr[0], "-all") == 0) {
  234.         argPtr++;
  235.         argc--;
  236.         all = 1;
  237.     } else {
  238.         break;
  239.     }
  240.     }
  241.     if (argc != 4) {
  242.     goto wrongNumArgs;
  243.     }
  244.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  245.     if (regexpPtr == NULL) {
  246.     return TCL_ERROR;
  247.     }
  248.  
  249.     /*
  250.      * Convert the string to lower case, if desired.
  251.      */
  252.  
  253.     if (noCase) {
  254.     register char *dst;
  255.  
  256.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  257.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  258.         if (isupper(*src)) {
  259.         *dst = tolower(*src);
  260.         } else {
  261.         *dst = *src;
  262.         }
  263.     }
  264.     *dst = 0;
  265.     } else {
  266.     string = argPtr[1];
  267.     }
  268.  
  269.     /*
  270.      * The following loop is to handle multiple matches within the
  271.      * same source string;  each iteration handles one match and its
  272.      * corresponding substitution.  If "-all" hasn't been specified
  273.      * then the loop body only gets executed once.
  274.      */
  275.  
  276.     flags = 0;
  277.     for (p = string; *p != 0; ) {
  278.     tclRegexpError = NULL;
  279.     match = regexec(regexpPtr, p);
  280.     if (tclRegexpError != NULL) {
  281.         Tcl_AppendResult(interp, "error while matching pattern: ",
  282.             tclRegexpError, (char *) NULL);
  283.         result = TCL_ERROR;
  284.         goto done;
  285.     }
  286.     if (!match) {
  287.         break;
  288.     }
  289.  
  290.     /*
  291.      * Copy the portion of the source string before the match to the
  292.      * result variable.
  293.      */
  294.     
  295.     src = argPtr[1] + (regexpPtr->startp[0] - string);
  296.     c = *src;
  297.     *src = 0;
  298.     newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  299.         flags);
  300.     *src = c;
  301.     flags = TCL_APPEND_VALUE;
  302.     if (newValue == NULL) {
  303.         cantSet:
  304.         Tcl_AppendResult(interp, "couldn't set variable \"",
  305.             argPtr[3], "\"", (char *) NULL);
  306.         result = TCL_ERROR;
  307.         goto done;
  308.     }
  309.     
  310.     /*
  311.      * Append the subSpec argument to the variable, making appropriate
  312.      * substitutions.  This code is a bit hairy because of the backslash
  313.      * conventions and because the code saves up ranges of characters in
  314.      * subSpec to reduce the number of calls to Tcl_SetVar.
  315.      */
  316.     
  317.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  318.         int index;
  319.     
  320.         if (c == '&') {
  321.         index = 0;
  322.         } else if (c == '\\') {
  323.         c = src[1];
  324.         if ((c >= '0') && (c <= '9')) {
  325.             index = c - '0';
  326.         } else if ((c == '\\') || (c == '&')) {
  327.             *src = c;
  328.             src[1] = 0;
  329.             newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  330.                 TCL_APPEND_VALUE);
  331.             *src = '\\';
  332.             src[1] = c;
  333.             if (newValue == NULL) {
  334.             goto cantSet;
  335.             }
  336.             firstChar = src+2;
  337.             src++;
  338.             continue;
  339.         } else {
  340.             continue;
  341.         }
  342.         } else {
  343.         continue;
  344.         }
  345.         if (firstChar != src) {
  346.         c = *src;
  347.         *src = 0;
  348.         newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  349.             TCL_APPEND_VALUE);
  350.         *src = c;
  351.         if (newValue == NULL) {
  352.             goto cantSet;
  353.         }
  354.         }
  355.         if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
  356.             && (regexpPtr->endp[index] != NULL)) {
  357.         char *first, *last, saved;
  358.     
  359.         first = argPtr[1] + (regexpPtr->startp[index] - string);
  360.         last = argPtr[1] + (regexpPtr->endp[index] - string);
  361.         saved = *last;
  362.         *last = 0;
  363.         newValue = Tcl_SetVar(interp, argPtr[3], first,
  364.             TCL_APPEND_VALUE);
  365.         *last = saved;
  366.         if (newValue == NULL) {
  367.             goto cantSet;
  368.         }
  369.         }
  370.         if (*src == '\\') {
  371.         src++;
  372.         }
  373.         firstChar = src+1;
  374.     }
  375.     if (firstChar != src) {
  376.         if (Tcl_SetVar(interp, argPtr[3], firstChar,
  377.             TCL_APPEND_VALUE) == NULL) {
  378.         goto cantSet;
  379.         }
  380.     }
  381.     p = regexpPtr->endp[0];
  382.     if (!all) {
  383.         break;
  384.     }
  385.     }
  386.  
  387.     /*
  388.      * If there were no matches at all, then return a "0" result.
  389.      */
  390.  
  391.     if (p == string) {
  392.     interp->result = "0";
  393.     result = TCL_OK;
  394.     goto done;
  395.     }
  396.  
  397.     /*
  398.      * Copy the portion of the source string after the last match to the
  399.      * result variable.
  400.      */
  401.  
  402.     if (*p != 0) {
  403.     if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
  404.         goto cantSet;
  405.     }
  406.     }
  407.     interp->result = "1";
  408.     result = TCL_OK;
  409.  
  410.     done:
  411.     if (string != argPtr[1]) {
  412.     ckfree(string);
  413.     }
  414.     return result;
  415. }
  416.  
  417. /*
  418.  *----------------------------------------------------------------------
  419.  *
  420.  * Tcl_RenameCmd --
  421.  *
  422.  *    This procedure is invoked to process the "rename" Tcl command.
  423.  *    See the user documentation for details on what it does.
  424.  *
  425.  * Results:
  426.  *    A standard Tcl result.
  427.  *
  428.  * Side effects:
  429.  *    See the user documentation.
  430.  *
  431.  *----------------------------------------------------------------------
  432.  */
  433.  
  434.     /* ARGSUSED */
  435. int
  436. Tcl_RenameCmd(dummy, interp, argc, argv)
  437.     ClientData dummy;            /* Not used. */
  438.     Tcl_Interp *interp;            /* Current interpreter. */
  439.     int argc;                /* Number of arguments. */
  440.     char **argv;            /* Argument strings. */
  441. {
  442.     register Command *cmdPtr;
  443.     Interp *iPtr = (Interp *) interp;
  444.     Tcl_HashEntry *hPtr;
  445.     int new;
  446.  
  447.     if (argc != 3) {
  448.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  449.         " oldName newName\"", (char *) NULL);
  450.     return TCL_ERROR;
  451.     }
  452.     if (argv[2][0] == '\0') {
  453.     if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  454.         Tcl_AppendResult(interp, "can't delete \"", argv[1],
  455.             "\": command doesn't exist", (char *) NULL);
  456.         return TCL_ERROR;
  457.     }
  458.     return TCL_OK;
  459.     }
  460.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  461.     if (hPtr != NULL) {
  462.     Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  463.         "\": command already exists", (char *) NULL);
  464.     return TCL_ERROR;
  465.     }
  466.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  467.     if (hPtr == NULL) {
  468.     Tcl_AppendResult(interp, "can't rename \"", argv[1],
  469.         "\":  command doesn't exist", (char *) NULL);
  470.     return TCL_ERROR;
  471.     }
  472.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  473.     Tcl_DeleteHashEntry(hPtr);
  474.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  475.     Tcl_SetHashValue(hPtr, cmdPtr);
  476.     return TCL_OK;
  477. }
  478.  
  479. /*
  480.  *----------------------------------------------------------------------
  481.  *
  482.  * Tcl_ReturnCmd --
  483.  *
  484.  *    This procedure is invoked to process the "return" Tcl command.
  485.  *    See the user documentation for details on what it does.
  486.  *
  487.  * Results:
  488.  *    A standard Tcl result.
  489.  *
  490.  * Side effects:
  491.  *    See the user documentation.
  492.  *
  493.  *----------------------------------------------------------------------
  494.  */
  495.  
  496.     /* ARGSUSED */
  497. int
  498. Tcl_ReturnCmd(dummy, interp, argc, argv)
  499.     ClientData dummy;            /* Not used. */
  500.     Tcl_Interp *interp;            /* Current interpreter. */
  501.     int argc;                /* Number of arguments. */
  502.     char **argv;            /* Argument strings. */
  503. {
  504.     if (argc > 2) {
  505.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  506.         " ?value?\"", (char *) NULL);
  507.     return TCL_ERROR;
  508.     }
  509.     if (argc == 2) {
  510.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  511.     }
  512.     return TCL_RETURN;
  513. }
  514.  
  515. /*
  516.  *----------------------------------------------------------------------
  517.  *
  518.  * Tcl_ScanCmd --
  519.  *
  520.  *    This procedure is invoked to process the "scan" Tcl command.
  521.  *    See the user documentation for details on what it does.
  522.  *
  523.  * Results:
  524.  *    A standard Tcl result.
  525.  *
  526.  * Side effects:
  527.  *    See the user documentation.
  528.  *
  529.  *----------------------------------------------------------------------
  530.  */
  531.  
  532.     /* ARGSUSED */
  533. int
  534. Tcl_ScanCmd(dummy, interp, argc, argv)
  535.     ClientData dummy;            /* Not used. */
  536.     Tcl_Interp *interp;            /* Current interpreter. */
  537.     int argc;                /* Number of arguments. */
  538.     char **argv;            /* Argument strings. */
  539. {
  540.     int arg1Length;            /* Number of bytes in argument to be
  541.                      * scanned.  This gives an upper limit
  542.                      * on string field sizes. */
  543. #   define MAX_FIELDS 20
  544.     typedef struct {
  545.     char fmt;            /* Format for field. */
  546.     int size;            /* How many bytes to allow for
  547.                      * field. */
  548.     char *location;            /* Where field will be stored. */
  549.     } Field;
  550.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  551.                      * format string. */
  552.     register Field *curField;
  553.     int numFields = 0;            /* Number of fields actually
  554.                      * specified. */
  555.     int suppress;            /* Current field is assignment-
  556.                      * suppressed. */
  557.     int totalSize = 0;            /* Number of bytes needed to store
  558.                      * all results combined. */
  559.     char *results;            /* Where scanned output goes.  */
  560.     int numScanned;            /* sscanf's result. */
  561.     register char *fmt;
  562.     int i, widthSpecified;
  563.  
  564.     if (argc < 3) {
  565.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  566.         " string format ?varName varName ...?\"", (char *) NULL);
  567.     return TCL_ERROR;
  568.     }
  569.  
  570.     /*
  571.      * This procedure operates in four stages:
  572.      * 1. Scan the format string, collecting information about each field.
  573.      * 2. Allocate an array to hold all of the scanned fields.
  574.      * 3. Call sscanf to do all the dirty work, and have it store the
  575.      *    parsed fields in the array.
  576.      * 4. Pick off the fields from the array and assign them to variables.
  577.      */
  578.  
  579.     arg1Length = (strlen(argv[1]) + 4) & ~03;
  580.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  581.     if (*fmt != '%') {
  582.         continue;
  583.     }
  584.     fmt++;
  585.     if (*fmt == '*') {
  586.         suppress = 1;
  587.         fmt++;
  588.     } else {
  589.         suppress = 0;
  590.     }
  591.     widthSpecified = 0;
  592.     while (isdigit(*fmt)) {
  593.         widthSpecified = 1;
  594.         fmt++;
  595.     }
  596.     if (suppress) {
  597.         continue;
  598.     }
  599.     if (numFields == MAX_FIELDS) {
  600.         interp->result = "too many fields to scan";
  601.         return TCL_ERROR;
  602.     }
  603.     curField = &fields[numFields];
  604.     numFields++;
  605.     switch (*fmt) {
  606.         case 'D':
  607.         case 'O':
  608.         case 'X':
  609.         case 'd':
  610.         case 'o':
  611.         case 'x':
  612.         curField->fmt = 'd';
  613.         curField->size = sizeof(int);
  614.         break;
  615.  
  616.         case 's':
  617.         curField->fmt = 's';
  618.         curField->size = arg1Length;
  619.         break;
  620.  
  621.         case 'c':
  622.                 if (widthSpecified) {
  623.                     interp->result = 
  624.                          "field width may not be specified in %c conversion";
  625.                     return TCL_ERROR;
  626.                 }
  627.         curField->fmt = 'c';
  628.         curField->size = sizeof(int);
  629.         break;
  630.  
  631.         case 'E':
  632.         case 'F':
  633.         curField->fmt = 'F';
  634.         curField->size = sizeof(double);
  635.         break;
  636.  
  637.         case 'e':
  638.         case 'f':
  639.         curField->fmt = 'f';
  640.         curField->size = sizeof(float);
  641.         break;
  642.  
  643.         case '[':
  644.         curField->fmt = 's';
  645.         curField->size = arg1Length;
  646.         do {
  647.             fmt++;
  648.         } while (*fmt != ']');
  649.         break;
  650.  
  651.         default:
  652.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  653.             *fmt);
  654.         return TCL_ERROR;
  655.     }
  656.     totalSize += curField->size;
  657.     }
  658.  
  659.     if (numFields != (argc-3)) {
  660.     interp->result =
  661.         "different numbers of variable names and field specifiers";
  662.     return TCL_ERROR;
  663.     }
  664.  
  665.     /*
  666.      * Step 2:
  667.      */
  668.  
  669.     results = (char *) ckalloc((unsigned) totalSize);
  670.     for (i = 0, totalSize = 0, curField = fields;
  671.         i < numFields; i++, curField++) {
  672.     curField->location = results + totalSize;
  673.     totalSize += curField->size;
  674.     }
  675.  
  676.     /*
  677.      * Fill in the remaining fields with NULL;  the only purpose of
  678.      * this is to keep some memory analyzers, like Purify, from
  679.      * complaining.
  680.      */
  681.  
  682.     for ( ; i < MAX_FIELDS; i++, curField++) {
  683.     curField->location = NULL;
  684.     }
  685.  
  686.     /*
  687.      * Step 3:
  688.      */
  689.  
  690.     numScanned = sscanf(argv[1], argv[2],
  691.         fields[0].location, fields[1].location, fields[2].location,
  692.         fields[3].location, fields[4].location, fields[5].location,
  693.         fields[6].location, fields[7].location, fields[8].location,
  694.         fields[9].location, fields[10].location, fields[11].location,
  695.         fields[12].location, fields[13].location, fields[14].location,
  696.         fields[15].location, fields[16].location, fields[17].location,
  697.         fields[18].location, fields[19].location);
  698.  
  699.     /*
  700.      * Step 4:
  701.      */
  702.  
  703.     if (numScanned < numFields) {
  704.     numFields = numScanned;
  705.     }
  706.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  707.     switch (curField->fmt) {
  708.         char string[120];
  709.  
  710.         case 'd':
  711.         sprintf(string, "%d", *((int *) curField->location));
  712.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  713.             storeError:
  714.             Tcl_AppendResult(interp,
  715.                 "couldn't set variable \"", argv[i+3], "\"",
  716.                 (char *) NULL);
  717.             ckfree((char *) results);
  718.             return TCL_ERROR;
  719.         }
  720.         break;
  721.  
  722.         case 'c':
  723.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  724.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  725.             goto storeError;
  726.         }
  727.         break;
  728.  
  729.         case 's':
  730.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  731.             == NULL) {
  732.             goto storeError;
  733.         }
  734.         break;
  735.  
  736.         case 'F':
  737.         sprintf(string, "%g", *((double *) curField->location));
  738.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  739.             goto storeError;
  740.         }
  741.         break;
  742.  
  743.         case 'f':
  744.         sprintf(string, "%g", *((float *) curField->location));
  745.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  746.             goto storeError;
  747.         }
  748.         break;
  749.     }
  750.     }
  751.     ckfree(results);
  752.     sprintf(interp->result, "%d", numScanned);
  753.     return TCL_OK;
  754. }
  755.  
  756. /*
  757.  *----------------------------------------------------------------------
  758.  *
  759.  * Tcl_SplitCmd --
  760.  *
  761.  *    This procedure is invoked to process the "split" Tcl command.
  762.  *    See the user documentation for details on what it does.
  763.  *
  764.  * Results:
  765.  *    A standard Tcl result.
  766.  *
  767.  * Side effects:
  768.  *    See the user documentation.
  769.  *
  770.  *----------------------------------------------------------------------
  771.  */
  772.  
  773.     /* ARGSUSED */
  774. int
  775. Tcl_SplitCmd(dummy, interp, argc, argv)
  776.     ClientData dummy;            /* Not used. */
  777.     Tcl_Interp *interp;            /* Current interpreter. */
  778.     int argc;                /* Number of arguments. */
  779.     char **argv;            /* Argument strings. */
  780. {
  781.     char *splitChars;
  782.     register char *p, *p2;
  783.     char *elementStart;
  784.  
  785.     if (argc == 2) {
  786.     splitChars = " \n\t\r";
  787.     } else if (argc == 3) {
  788.     splitChars = argv[2];
  789.     } else {
  790.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  791.         " string ?splitChars?\"", (char *) NULL);
  792.     return TCL_ERROR;
  793.     }
  794.  
  795.     /*
  796.      * Handle the special case of splitting on every character.
  797.      */
  798.  
  799.     if (*splitChars == 0) {
  800.     char string[2];
  801.     string[1] = 0;
  802.     for (p = argv[1]; *p != 0; p++) {
  803.         string[0] = *p;
  804.         Tcl_AppendElement(interp, string, 0);
  805.     }
  806.     return TCL_OK;
  807.     }
  808.  
  809.     /*
  810.      * Normal case: split on any of a given set of characters.
  811.      * Discard instances of the split characters.
  812.      */
  813.  
  814.     for (p = elementStart = argv[1]; *p != 0; p++) {
  815.     char c = *p;
  816.     for (p2 = splitChars; *p2 != 0; p2++) {
  817.         if (*p2 == c) {
  818.         *p = 0;
  819.         Tcl_AppendElement(interp, elementStart, 0);
  820.         *p = c;
  821.         elementStart = p+1;
  822.         break;
  823.         }
  824.     }
  825.     }
  826.     if (p != argv[1]) {
  827.     Tcl_AppendElement(interp, elementStart, 0);
  828.     }
  829.     return TCL_OK;
  830. }
  831.  
  832. /*
  833.  *----------------------------------------------------------------------
  834.  *
  835.  * Tcl_StringCmd --
  836.  *
  837.  *    This procedure is invoked to process the "string" Tcl command.
  838.  *    See the user documentation for details on what it does.
  839.  *
  840.  * Results:
  841.  *    A standard Tcl result.
  842.  *
  843.  * Side effects:
  844.  *    See the user documentation.
  845.  *
  846.  *----------------------------------------------------------------------
  847.  */
  848.  
  849.     /* ARGSUSED */
  850. int
  851. Tcl_StringCmd(dummy, interp, argc, argv)
  852.     ClientData dummy;            /* Not used. */
  853.     Tcl_Interp *interp;            /* Current interpreter. */
  854.     int argc;                /* Number of arguments. */
  855.     char **argv;            /* Argument strings. */
  856. {
  857.     int length;
  858.     register char *p, c;
  859.     int match;
  860.     int first;
  861.     int left = 0, right = 0;
  862.  
  863.     if (argc < 2) {
  864.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  865.         " option arg ?arg ...?\"", (char *) NULL);
  866.     return TCL_ERROR;
  867.     }
  868.     c = argv[1][0];
  869.     length = strlen(argv[1]);
  870.     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  871.     if (argc != 4) {
  872.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  873.             " compare string1 string2\"", (char *) NULL);
  874.         return TCL_ERROR;
  875.     }
  876.     match = strcmp(argv[2], argv[3]);
  877.     if (match > 0) {
  878.         interp->result = "1";
  879.     } else if (match < 0) {
  880.         interp->result = "-1";
  881.     } else {
  882.         interp->result = "0";
  883.     }
  884.     return TCL_OK;
  885.     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  886.     if (argc != 4) {
  887.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  888.             " first string1 string2\"", (char *) NULL);
  889.         return TCL_ERROR;
  890.     }
  891.     first = 1;
  892.  
  893.     firstLast:
  894.     match = -1;
  895.     c = *argv[2];
  896.     length = strlen(argv[2]);
  897.     for (p = argv[3]; *p != 0; p++) {
  898.         if (*p != c) {
  899.         continue;
  900.         }
  901.         if (strncmp(argv[2], p, length) == 0) {
  902.         match = p-argv[3];
  903.         if (first) {
  904.             break;
  905.         }
  906.         }
  907.     }
  908.     sprintf(interp->result, "%d", match);
  909.     return TCL_OK;
  910.     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  911.     int index;
  912.  
  913.     if (argc != 4) {
  914.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  915.             " index string charIndex\"", (char *) NULL);
  916.         return TCL_ERROR;
  917.     }
  918.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  919.         return TCL_ERROR;
  920.     }
  921.     if ((index >= 0) && (index < strlen(argv[2]))) {
  922.         interp->result[0] = argv[2][index];
  923.         interp->result[1] = 0;
  924.     }
  925.     return TCL_OK;
  926.     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  927.         && (length >= 2)) {
  928.     if (argc != 4) {
  929.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  930.             " last string1 string2\"", (char *) NULL);
  931.         return TCL_ERROR;
  932.     }
  933.     first = 0;
  934.     goto firstLast;
  935.     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  936.         && (length >= 2)) {
  937.     if (argc != 3) {
  938.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  939.             " length string\"", (char *) NULL);
  940.         return TCL_ERROR;
  941.     }
  942.     sprintf(interp->result, "%d", strlen(argv[2]));
  943.     return TCL_OK;
  944.     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  945.     if (argc != 4) {
  946.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  947.             " match pattern string\"", (char *) NULL);
  948.         return TCL_ERROR;
  949.     }
  950.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  951.         interp->result = "1";
  952.     } else {
  953.         interp->result = "0";
  954.     }
  955.     return TCL_OK;
  956.     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  957.     int first, last, stringLength;
  958.  
  959.     if (argc != 5) {
  960.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  961.             " range string first last\"", (char *) NULL);
  962.         return TCL_ERROR;
  963.     }
  964.     stringLength = strlen(argv[2]);
  965.     if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  966.         return TCL_ERROR;
  967.     }
  968.     if ((*argv[4] == 'e')
  969.         && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  970.         last = stringLength-1;
  971.     } else {
  972.         if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  973.         Tcl_ResetResult(interp);
  974.         Tcl_AppendResult(interp,
  975.             "expected integer or \"end\" but got \"",
  976.             argv[4], "\"", (char *) NULL);
  977.         return TCL_ERROR;
  978.         }
  979.     }
  980.     if (first < 0) {
  981.         first = 0;
  982.     }
  983.     if (last >= stringLength) {
  984.         last = stringLength-1;
  985.     }
  986.     if (last >= first) {
  987.         char saved, *p;
  988.  
  989.         p = argv[2] + last + 1;
  990.         saved = *p;
  991.         *p = 0;
  992.         Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  993.         *p = saved;
  994.     }
  995.     return TCL_OK;
  996.     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  997.         && (length >= 3)) {
  998.     register char *p;
  999.  
  1000.     if (argc != 3) {
  1001.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1002.             " tolower string\"", (char *) NULL);
  1003.         return TCL_ERROR;
  1004.     }
  1005.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1006.     for (p = interp->result; *p != 0; p++) {
  1007.         if (isupper(*p)) {
  1008.         *p = tolower(*p);
  1009.         }
  1010.     }
  1011.     return TCL_OK;
  1012.     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1013.         && (length >= 3)) {
  1014.     register char *p;
  1015.  
  1016.     if (argc != 3) {
  1017.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1018.             " toupper string\"", (char *) NULL);
  1019.         return TCL_ERROR;
  1020.     }
  1021.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1022.     for (p = interp->result; *p != 0; p++) {
  1023.         if (islower(*p)) {
  1024.         *p = toupper(*p);
  1025.         }
  1026.     }
  1027.     return TCL_OK;
  1028.     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1029.         && (length == 4)) {
  1030.     char *trimChars;
  1031.     register char *p, *checkPtr;
  1032.  
  1033.     left = right = 1;
  1034.  
  1035.     trim:
  1036.     if (argc == 4) {
  1037.         trimChars = argv[3];
  1038.     } else if (argc == 3) {
  1039.         trimChars = " \t\n\r";
  1040.     } else {
  1041.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1042.             " ", argv[1], " string ?chars?\"", (char *) NULL);
  1043.         return TCL_ERROR;
  1044.     }
  1045.     p = argv[2];
  1046.     if (left) {
  1047.         for (c = *p; c != 0; p++, c = *p) {
  1048.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1049.             if (*checkPtr == 0) {
  1050.             goto doneLeft;
  1051.             }
  1052.         }
  1053.         }
  1054.     }
  1055.     doneLeft:
  1056.     Tcl_SetResult(interp, p, TCL_VOLATILE);
  1057.     if (right) {
  1058.         char *donePtr;
  1059.  
  1060.         p = interp->result + strlen(interp->result) - 1;
  1061.         donePtr = &interp->result[-1];
  1062.         for (c = *p; p != donePtr; p--, c = *p) {
  1063.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1064.             if (*checkPtr == 0) {
  1065.             goto doneRight;
  1066.             }
  1067.         }
  1068.         }
  1069.         doneRight:
  1070.         p[1] = 0;
  1071.     }
  1072.     return TCL_OK;
  1073.     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1074.         && (length > 4)) {
  1075.     left = 1;
  1076.     argv[1] = "trimleft";
  1077.     goto trim;
  1078.     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1079.         && (length > 4)) {
  1080.     right = 1;
  1081.     argv[1] = "trimright";
  1082.     goto trim;
  1083.     } else {
  1084.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1085.         "\": should be compare, first, index, last, length, match, ",
  1086.         "range, tolower, toupper, trim, trimleft, or trimright",
  1087.         (char *) NULL);
  1088.     return TCL_ERROR;
  1089.     }
  1090. }
  1091.  
  1092. /*
  1093.  *----------------------------------------------------------------------
  1094.  *
  1095.  * Tcl_TraceCmd --
  1096.  *
  1097.  *    This procedure is invoked to process the "trace" Tcl command.
  1098.  *    See the user documentation for details on what it does.
  1099.  *
  1100.  * Results:
  1101.  *    A standard Tcl result.
  1102.  *
  1103.  * Side effects:
  1104.  *    See the user documentation.
  1105.  *
  1106.  *----------------------------------------------------------------------
  1107.  */
  1108.  
  1109.     /* ARGSUSED */
  1110. int
  1111. Tcl_TraceCmd(dummy, interp, argc, argv)
  1112.     ClientData dummy;            /* Not used. */
  1113.     Tcl_Interp *interp;            /* Current interpreter. */
  1114.     int argc;                /* Number of arguments. */
  1115.     char **argv;            /* Argument strings. */
  1116. {
  1117.     char c;
  1118.     int length;
  1119.  
  1120.     if (argc < 2) {
  1121.     Tcl_AppendResult(interp, "too few args: should be \"",
  1122.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1123.     return TCL_ERROR;
  1124.     }
  1125.     c = argv[1][1];
  1126.     length = strlen(argv[1]);
  1127.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1128.         && (length >= 2)) {
  1129.     char *p;
  1130.     int flags, length;
  1131.     TraceVarInfo *tvarPtr;
  1132.  
  1133.     if (argc != 5) {
  1134.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1135.             argv[0], " variable name ops command\"", (char *) NULL);
  1136.         return TCL_ERROR;
  1137.     }
  1138.  
  1139.     flags = 0;
  1140.     for (p = argv[3] ; *p != 0; p++) {
  1141.         if (*p == 'r') {
  1142.         flags |= TCL_TRACE_READS;
  1143.         } else if (*p == 'w') {
  1144.         flags |= TCL_TRACE_WRITES;
  1145.         } else if (*p == 'u') {
  1146.         flags |= TCL_TRACE_UNSETS;
  1147.         } else {
  1148.         goto badOps;
  1149.         }
  1150.     }
  1151.     if (flags == 0) {
  1152.         goto badOps;
  1153.     }
  1154.  
  1155.     length = strlen(argv[4]);
  1156.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1157.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1158.     tvarPtr->flags = flags;
  1159.     tvarPtr->length = length;
  1160.     flags |= TCL_TRACE_UNSETS;
  1161.     strcpy(tvarPtr->command, argv[4]);
  1162.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1163.         (ClientData) tvarPtr) != TCL_OK) {
  1164.         ckfree((char *) tvarPtr);
  1165.         return TCL_ERROR;
  1166.     }
  1167.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1168.         && (length >= 2)) == 0) {
  1169.     char *p;
  1170.     int flags, length;
  1171.     TraceVarInfo *tvarPtr;
  1172.     ClientData clientData;
  1173.  
  1174.     if (argc != 5) {
  1175.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1176.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1177.         return TCL_ERROR;
  1178.     }
  1179.  
  1180.     flags = 0;
  1181.     for (p = argv[3] ; *p != 0; p++) {
  1182.         if (*p == 'r') {
  1183.         flags |= TCL_TRACE_READS;
  1184.         } else if (*p == 'w') {
  1185.         flags |= TCL_TRACE_WRITES;
  1186.         } else if (*p == 'u') {
  1187.         flags |= TCL_TRACE_UNSETS;
  1188.         } else {
  1189.         goto badOps;
  1190.         }
  1191.     }
  1192.     if (flags == 0) {
  1193.         goto badOps;
  1194.     }
  1195.  
  1196.     /*
  1197.      * Search through all of our traces on this variable to
  1198.      * see if there's one with the given command.  If so, then
  1199.      * delete the first one that matches.
  1200.      */
  1201.  
  1202.     length = strlen(argv[4]);
  1203.     clientData = 0;
  1204.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1205.         TraceVarProc, clientData)) != 0) {
  1206.         tvarPtr = (TraceVarInfo *) clientData;
  1207.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1208.             && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
  1209.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1210.             TraceVarProc, clientData);
  1211.         ckfree((char *) tvarPtr);
  1212.         break;
  1213.         }
  1214.     }
  1215.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1216.         && (length >= 2)) {
  1217.     ClientData clientData;
  1218.     char ops[4], *p;
  1219.     char *prefix = "{";
  1220.  
  1221.     if (argc != 3) {
  1222.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1223.             argv[0], " vinfo name\"", (char *) NULL);
  1224.         return TCL_ERROR;
  1225.     }
  1226.     clientData = 0;
  1227.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1228.         TraceVarProc, clientData)) != 0) {
  1229.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1230.         p = ops;
  1231.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1232.         *p = 'r';
  1233.         p++;
  1234.         }
  1235.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1236.         *p = 'w';
  1237.         p++;
  1238.         }
  1239.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1240.         *p = 'u';
  1241.         p++;
  1242.         }
  1243.         *p = '\0';
  1244.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1245.         Tcl_AppendElement(interp, ops, 1);
  1246.         Tcl_AppendElement(interp, tvarPtr->command, 0);
  1247.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1248.         prefix = " {";
  1249.     }
  1250.     } else {
  1251.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1252.         "\": should be variable, vdelete, or vinfo",
  1253.         (char *) NULL);
  1254.     return TCL_ERROR;
  1255.     }
  1256.     return TCL_OK;
  1257.  
  1258.     badOps:
  1259.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1260.         "\": should be one or more of rwu", (char *) NULL);
  1261.     return TCL_ERROR;
  1262. }
  1263.  
  1264. /*
  1265.  *----------------------------------------------------------------------
  1266.  *
  1267.  * TraceVarProc --
  1268.  *
  1269.  *    This procedure is called to handle variable accesses that have
  1270.  *    been traced using the "trace" command.
  1271.  *
  1272.  * Results:
  1273.  *    Normally returns NULL.  If the trace command returns an error,
  1274.  *    then this procedure returns an error string.
  1275.  *
  1276.  * Side effects:
  1277.  *    Depends on the command associated with the trace.
  1278.  *
  1279.  *----------------------------------------------------------------------
  1280.  */
  1281.  
  1282.     /* ARGSUSED */
  1283. static char *
  1284. TraceVarProc(clientData, interp, name1, name2, flags)
  1285.     ClientData clientData;    /* Information about the variable trace. */
  1286.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1287.     char *name1;        /* Name of variable or array. */
  1288.     char *name2;        /* Name of element within array;  NULL means
  1289.                  * scalar variable is being referenced. */
  1290.     int flags;            /* OR-ed bits giving operation and other
  1291.                  * information. */
  1292. {
  1293.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1294.     char *result;
  1295.     int code, cmdLength, flags1, flags2;
  1296.     Interp dummy;
  1297. #define STATIC_SIZE 199
  1298.     char staticSpace[STATIC_SIZE+1];
  1299.     char *cmdPtr, *p;
  1300.  
  1301.     result = NULL;
  1302.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1303.  
  1304.     /*
  1305.      * Generate a command to execute by appending list elements
  1306.      * for the two variable names and the operation.  The five
  1307.      * extra characters are for three space, the opcode character,
  1308.      * and the terminating null.
  1309.      */
  1310.  
  1311.     if (name2 == NULL) {
  1312.         name2 = "";
  1313.     }
  1314.     cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
  1315.         Tcl_ScanElement(name2, &flags2) + 5;
  1316.     if (cmdLength < STATIC_SIZE) {
  1317.         cmdPtr = staticSpace;
  1318.     } else {
  1319.         cmdPtr = (char *) ckalloc((unsigned) cmdLength);
  1320.     }
  1321.     p = cmdPtr;
  1322.     strcpy(p, tvarPtr->command);
  1323.     p += tvarPtr->length;
  1324.     *p = ' ';
  1325.     p++;
  1326.     p += Tcl_ConvertElement(name1, p, flags1);
  1327.     *p = ' ';
  1328.     p++;
  1329.     p += Tcl_ConvertElement(name2, p, flags2);
  1330.     *p = ' ';
  1331.     if (flags & TCL_TRACE_READS) {
  1332.         p[1] = 'r';
  1333.     } else if (flags & TCL_TRACE_WRITES) {
  1334.         p[1] = 'w';
  1335.     } else if (flags & TCL_TRACE_UNSETS) {
  1336.         p[1] = 'u';
  1337.     }
  1338.     p[2] = '\0';
  1339.  
  1340.     /*
  1341.      * Execute the command.  Be careful to save and restore the
  1342.      * result from the interpreter used for the command.
  1343.      */
  1344.  
  1345.     if (interp->freeProc == 0) {
  1346.         dummy.freeProc = (Tcl_FreeProc *) 0;
  1347.         dummy.result = "";
  1348.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1349.     } else {
  1350.         dummy.freeProc = interp->freeProc;
  1351.         dummy.result = interp->result;
  1352.     }
  1353.     code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
  1354.     if (cmdPtr != staticSpace) {
  1355.         ckfree(cmdPtr);
  1356.     }
  1357.     if (code != TCL_OK) {
  1358.         result = "access disallowed by trace command";
  1359.         Tcl_ResetResult(interp);        /* Must clear error state. */
  1360.     }
  1361.     Tcl_FreeResult(interp);
  1362.     interp->result = dummy.result;
  1363.     interp->freeProc = dummy.freeProc;
  1364.     }
  1365.     if (flags & TCL_TRACE_DESTROYED) {
  1366.     ckfree((char *) tvarPtr);
  1367.     }
  1368.     return result;
  1369. }
  1370.  
  1371. /*
  1372.  *----------------------------------------------------------------------
  1373.  *
  1374.  * Tcl_WhileCmd --
  1375.  *
  1376.  *    This procedure is invoked to process the "while" Tcl command.
  1377.  *    See the user documentation for details on what it does.
  1378.  *
  1379.  * Results:
  1380.  *    A standard Tcl result.
  1381.  *
  1382.  * Side effects:
  1383.  *    See the user documentation.
  1384.  *
  1385.  *----------------------------------------------------------------------
  1386.  */
  1387.  
  1388.     /* ARGSUSED */
  1389. int
  1390. Tcl_WhileCmd(dummy, interp, argc, argv)
  1391.     ClientData dummy;            /* Not used. */
  1392.     Tcl_Interp *interp;            /* Current interpreter. */
  1393.     int argc;                /* Number of arguments. */
  1394.     char **argv;            /* Argument strings. */
  1395. {
  1396.     int result, value;
  1397.  
  1398.     if (argc != 3) {
  1399.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1400.         argv[0], " test command\"", (char *) NULL);
  1401.     return TCL_ERROR;
  1402.     }
  1403.  
  1404.     while (1) {
  1405.     result = Tcl_ExprBoolean(interp, argv[1], &value);
  1406.     if (result != TCL_OK) {
  1407.         return result;
  1408.     }
  1409.     if (!value) {
  1410.         break;
  1411.     }
  1412.     result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
  1413.     if (result == TCL_CONTINUE) {
  1414.         result = TCL_OK;
  1415.     } else if (result != TCL_OK) {
  1416.         if (result == TCL_ERROR) {
  1417.         char msg[60];
  1418.         sprintf(msg, "\n    (\"while\" body line %d)",
  1419.             interp->errorLine);
  1420.         Tcl_AddErrorInfo(interp, msg);
  1421.         }
  1422.         break;
  1423.     }
  1424.     }
  1425.     if (result == TCL_BREAK) {
  1426.     result = TCL_OK;
  1427.     }
  1428.     if (result == TCL_OK) {
  1429.     Tcl_ResetResult(interp);
  1430.     }
  1431.     return result;
  1432. }
  1433.